#lang racket


;;https://gitee.com/wu-org/isa/blob/master/Tao3.rkt

(require srfi/13)
(require racket/list)

;; machine defination
(define CODE-SEG-BEGIN 0)
(define CODE-SEG-LEN 1024)
(define DATA-SEG-BEGIN 1024) ; 只要有把握，设成和CODE-SEG-BEGIN相同也可以的
(define DATA-SEG-LEN 256)
(define FRAME-BUFFER-BEGIN (+ DATA-SEG-BEGIN DATA-SEG-LEN))
(define FRAME-BUFFER-WIDTH  32)   ; 屏幕宽
(define FRAME-BUFFER-HEIGTH 32)   ; 屏幕高
(define MEM-LEN (+ FRAME-BUFFER-BEGIN (* FRAME-BUFFER-WIDTH FRAME-BUFFER-HEIGTH)))
(define MEM (make-vector MEM-LEN 0))
(define COINS-REMAIN 2618) ; 每运行一个周期消耗一个币
(define PC           0)
(define REGSTACK '())
(define CYCLES   0)


;; basic facility
(define (push! x)           (set! REGSTACK (cons x REGSTACK)))
(define (pop!)              (let ((result (car REGSTACK))) (set! REGSTACK (cdr REGSTACK)) result))
(define (set-pc! n)         (set! PC n) PC)
(define (pc+!    n)         (set-pc! (+ PC n)))
(define (read-code addr)    (vector-ref MEM (+ addr CODE-SEG-BEGIN)))
(define (get-arg n)         (read-code (+ n PC)))
(define (get-data addr)     (vector-ref  MEM (+ addr DATA-SEG-BEGIN)))
(define (set-data! addr val)(vector-set! MEM (+ addr DATA-SEG-BEGIN) val))
(define (get-instr)         (read-code PC))
(define (set-color! x y color)     (vector-set! MEM (+ (* (remainder y FRAME-BUFFER-HEIGTH) FRAME-BUFFER-WIDTH)
                                                       (remainder x FRAME-BUFFER-WIDTH)
                                                       FRAME-BUFFER-BEGIN)
                                                color))
(define (get-color x y)            (vector-ref  MEM (+ (* (remainder y FRAME-BUFFER-HEIGTH) FRAME-BUFFER-WIDTH)
                                                       (remainder x FRAME-BUFFER-WIDTH)
                                                       FRAME-BUFFER-BEGIN)))
(define (render-frame-buffer)
  (define (format-number n width)
    (string-pad (number->string n) width #\space))

  ;; 或者更简单地使用字符串连接
  (define (format-2d n)
    (let ((str (number->string n)))
      (if (< (string-length str) 2)
          (string-append " " str)
          str)))
  (display (format "帧缓冲区内容 (~ax~a):\n" FRAME-BUFFER-WIDTH FRAME-BUFFER-HEIGTH))
  (display "   ")
  ;; 打印列号
  (for-each (lambda (x) (display (format-2d x))) (range FRAME-BUFFER-WIDTH))
  (newline)

  (for ([y (in-range FRAME-BUFFER-HEIGTH)])
    (display (format-2d y))  ;; 打印行号
    (for ([x (in-range FRAME-BUFFER-WIDTH)])
      (let ((color (get-color x y)))
        (display
         (cond
           [(= color 0) "  "]   ;; 黑色 - 空格
           [(= color 1) "██"]   ;; 白色 - 实心方块
           [(= color 2) "▓▓"]   ;; 灰色 - 半实心方块
           [(= color 3) "░░"]   ;; 浅灰 - 点状方块
           [else (format-2d color)]))))  ;; 其他颜色用十六进制显示
    (newline)))

;; ISA defination
(define ISA
  (list
   ;;     op             code  args  action
   (list 'NOP            #x00  0 (lambda ()                                                                                (pc+! 1)))
   (list 'PUSH           #x01  1 (lambda () (push! (get-arg 1))                                                            (pc+! 2)))
   (list 'POP            #x02  0 (lambda () (pop!)                                                                         (pc+! 1)))
   (list 'ADD            #x11  0 (lambda () (push! (let* ((op2 (pop!)) (op1 (pop!))) (+ op1 op2)))                         (pc+! 1)))
   (list 'SUB            #x12  0 (lambda () (push! (let* ((op2 (pop!)) (op1 (pop!))) (- op1 op2)))                         (pc+! 1)))
   (list 'MUL            #x13  0 (lambda () (push! (let* ((op2 (pop!)) (op1 (pop!))) (* op1 op2)))                         (pc+! 1)))
   (list 'DIV            #x14  0 (lambda () (push! (let* ((op2 (pop!)) (op1 (pop!))) (/ op1 op2)))                         (pc+! 1)))
   (list 'MOD            #x15  0 (lambda () (push! (let* ((op2 (pop!)) (op1 (pop!))) (remainder op1 op2)))                 (pc+! 1)))
   (list 'AND            #x21  0 (lambda () (push! (let* ((op2 (pop!)) (op1 (pop!))) (bitwise-and op1 op2)))               (pc+! 1)))
   (list 'OR             #x22  0 (lambda () (push! (let* ((op2 (pop!)) (op1 (pop!))) (bitwise-ior op1 op2)))               (pc+! 1)))
   (list 'NOT            #x23  0 (lambda () (push! (let* ((op1 (pop!)))               (bitwise-not op1)))                  (pc+! 1)))
   (list 'EQ             #x31  0 (lambda () (push! (let* ((op2 (pop!)) (op1 (pop!))) (if (= op1 op2) 1 0)))                (pc+! 1)))
   (list 'GT             #x32  0 (lambda () (push! (let* ((op2 (pop!)) (op1 (pop!))) (if (> op1 op2) 1 0)))                (pc+! 1)))
   (list 'LT             #x33  0 (lambda () (push! (let* ((op2 (pop!)) (op1 (pop!))) (if (< op1 op2) 1 0)))                (pc+! 1)))
   (list 'STORE          #x41  0 (lambda () (let* ((val (pop!)) (addr (pop!))) (set-data! addr val))                       (pc+! 1)))
   (list 'LOAD           #x42  0 (lambda () (let* ((addr (pop!))) (push! (get-data addr)))                                 (pc+! 1)))
   (list 'COPY           #x43  0 (lambda () (let* ((addr2 (pop!)) (addr1 (pop!))) (set-data! addr2 (get-data addr1)))      (pc+! 1)))
   (list 'JUMP           #x51  1 (lambda ()                        (set-pc! (get-arg 1))))
   (list 'JUMPIF         #x52  1 (lambda () (if (not (= (pop!) 0)) (set-pc! (get-arg 1))                                   (pc+! 2))))
   (list 'PRINT          #x61  0 (lambda () (display (pop!)) (display #\newline)                                           (pc+! 1)))
   (list 'SET-COLOR      #x71  0 (lambda () (let* ((op3 (pop!)) (op2 (pop!)) (op1 (pop!))) (set-color! op1 op2 op3)        (pc+! 1))))
   (list 'GET-COLOR      #x72  0 (lambda () (let* ((op2 (pop!)) (op1 (pop!))) (get-color op1 op2)                          (pc+! 1))))
   (list 'HALT           #xff  0 (lambda ()                                                                                (pc+! 1)))
   ))
(define HALT-OPCODE (cadr (assoc 'HALT ISA)))
(define cdr-mapped-ISA (map cdr ISA))

(define (ASSEMBLE list-of-code)
  (define ALIAS_MAP '((P PUSH) (PP POP)
                    (+ ADD)(- SUB) (* MUL) (/ DIV) (% MOD)
                    (= EQ) (> GT) (< LT)
                    (& AND) (~ NOT)
                    (CP COPY)
                    (JMP JUMP)
                    (HLT HALT)
                    ))
  (define (label? val)
    (and (symbol? val)
         (let ((cur-str (symbol->string val)))
           (char=? #\: (string-ref cur-str (- (string-length cur-str) 1))))))

  (define (instruction? val)
    (assoc val ISA))

  (let* ((list-of-code (map
                        (lambda (v)
                          (if (symbol? v)
                              (string->symbol (string-upcase (symbol->string v)))
                              v))
                        list-of-code))
         (labels
          (let loop ((i 0)
                     (L list-of-code)
                     (result '()))
            (cond ((null? L)
                   result)
                  ((label? (car L))
                   (let* ((cur (car L))
                          (cur-str (symbol->string (car L)))
                          (cur-str-no-colon (string-drop-right cur-str 1)))
                     (loop i (cdr L) (cons `(,(string->symbol cur-str-no-colon) ,i) result))))
                  (else
                   (loop (+ i 1) (cdr L) result))))))
    (let loop ((L list-of-code)
               (reversed-result '()))
      (if (null? L)
          (list->vector (reverse reversed-result))
          (let ((cur-val (car L)))
            (cond
              ((number? cur-val)
               (loop (cdr L) (cons cur-val reversed-result)))
              ((instruction? cur-val)
               (let* ((instr-item (assoc cur-val ISA))
                      (instr-name (car instr-item))
                      (instr-code (cadr instr-item))
                      (arg-num    (caddr instr-item)))
                 (if (= 0 arg-num)
                     (loop (cdr L) (cons instr-code reversed-result))
                     (loop (cddr L)
                           (cons (if (number? (cadr L))
                                     (cadr L)
                                     (cadr (assoc (cadr L) labels)))
                                 (cons (cadr (assoc cur-val ISA)) reversed-result))))))
              ((assoc cur-val ALIAS_MAP)
               (let ((cur-instr-name (cadr (assoc cur-val ALIAS_MAP))))
                 (loop (cons cur-instr-name (cdr L)) reversed-result)))
              ((label? cur-val)
               (loop (cdr L) reversed-result))
              ((assoc cur-val labels) ; taget?
               (loop (cdr L) (cons (cadr (assoc cur-val labels)) reversed-result)))
              (else ; unkown symbol
               (error (format "unkown symbol: ~a" cur-val)))))))))

(define LOADER
  (lambda (BYTE-CODE)
    (vector-copy! MEM CODE-SEG-BEGIN BYTE-CODE)))



(define (dump-machine)
  `((CODE-SEG-BEGIN ,CODE-SEG-BEGIN)
    (CODE-SEG-LEN   ,CODE-SEG-LEN  )
    (DATA-SEG-BEGIN ,DATA-SEG-BEGIN)
    (DATA-SEG-LEN   ,DATA-SEG-LEN  )
    (PC             ,PC            )
    (REGSTACK       ,REGSTACK      )
    (MEM            ,MEM           )
    (COINS-REMAIN   ,COINS-REMAIN  )
    (CYCLES         ,CYCLES)))



(define (debug-print)
  (define dasm-list
    (map
     (lambda (item)
       `(,(cadr item) ,(car item)))
     ISA))

  (let* ((instr (get-instr))
         (item  (assoc instr cdr-mapped-ISA)))
    (display (format "~a\n"
                     `(CYCLES: ,CYCLES PC: ,PC REGSTACK: ,REGSTACK
                               instr:  (,(cadr (assoc instr dasm-list))
                                        ,@(build-list
                                           (cadr item)
                                           (lambda (i) (get-arg (+ i 1))))))))))




(define (step-machine!)
  (let* ((instr (get-instr))
         (item  (assoc instr cdr-mapped-ISA)))
    (debug-print)
    (cond (item ; 有这指令
           ((caddr item)))
          (else ; 没这指令
           (pc+! 1))))

  (set! COINS-REMAIN (- COINS-REMAIN 1))
  )


(define (RUN-MACHINE)
  (let loop ()
    (cond ((<= COINS-REMAIN 0) ; 没coin了
           (displayln 'NOT-ENOUGH-COINS)
           PC)
          ((>= PC MEM-LEN)
           (begin
             (set-pc! 0)
             (loop)))
          ((eq? (get-instr) HALT-OPCODE)
           (step-machine!)
           (set! CYCLES (+ 1 CYCLES))
           PC)
          (else
           (step-machine!)
           (set! CYCLES (+ 1 CYCLES))
           (loop)))))



(define test-code
  '(
    ;; 绘制更清晰的正方体框架
    
    ;; 前表面 - 白色实线
    PUSH 1  ; 白色
    
    ;; 前表面上边
    PUSH 10 PUSH 10 PUSH 1 SET-COLOR
    PUSH 11 PUSH 10 PUSH 1 SET-COLOR
    PUSH 12 PUSH 10 PUSH 1 SET-COLOR
    PUSH 13 PUSH 10 PUSH 1 SET-COLOR
    PUSH 14 PUSH 10 PUSH 1 SET-COLOR
    PUSH 15 PUSH 10 PUSH 1 SET-COLOR
    PUSH 16 PUSH 10 PUSH 1 SET-COLOR
    PUSH 17 PUSH 10 PUSH 1 SET-COLOR
    PUSH 18 PUSH 10 PUSH 1 SET-COLOR
    PUSH 19 PUSH 10 PUSH 1 SET-COLOR
    PUSH 20 PUSH 10 PUSH 1 SET-COLOR
    
    ;; 前表面右边
    PUSH 20 PUSH 11 PUSH 1 SET-COLOR
    PUSH 20 PUSH 12 PUSH 1 SET-COLOR
    PUSH 20 PUSH 13 PUSH 1 SET-COLOR
    PUSH 20 PUSH 14 PUSH 1 SET-COLOR
    PUSH 20 PUSH 15 PUSH 1 SET-COLOR
    PUSH 20 PUSH 16 PUSH 1 SET-COLOR
    PUSH 20 PUSH 17 PUSH 1 SET-COLOR
    PUSH 20 PUSH 18 PUSH 1 SET-COLOR
    PUSH 20 PUSH 19 PUSH 1 SET-COLOR
    PUSH 20 PUSH 20 PUSH 1 SET-COLOR
    
    ;; 前表面下边
    PUSH 19 PUSH 20 PUSH 1 SET-COLOR
    PUSH 18 PUSH 20 PUSH 1 SET-COLOR
    PUSH 17 PUSH 20 PUSH 1 SET-COLOR
    PUSH 16 PUSH 20 PUSH 1 SET-COLOR
    PUSH 15 PUSH 20 PUSH 1 SET-COLOR
    PUSH 14 PUSH 20 PUSH 1 SET-COLOR
    PUSH 13 PUSH 20 PUSH 1 SET-COLOR
    PUSH 12 PUSH 20 PUSH 1 SET-COLOR
    PUSH 11 PUSH 20 PUSH 1 SET-COLOR
    PUSH 10 PUSH 20 PUSH 1 SET-COLOR
    
    ;; 前表面左边
    PUSH 10 PUSH 19 PUSH 1 SET-COLOR
    PUSH 10 PUSH 18 PUSH 1 SET-COLOR
    PUSH 10 PUSH 17 PUSH 1 SET-COLOR
    PUSH 10 PUSH 16 PUSH 1 SET-COLOR
    PUSH 10 PUSH 15 PUSH 1 SET-COLOR
    PUSH 10 PUSH 14 PUSH 1 SET-COLOR
    PUSH 10 PUSH 13 PUSH 1 SET-COLOR
    PUSH 10 PUSH 12 PUSH 1 SET-COLOR
    PUSH 10 PUSH 11 PUSH 1 SET-COLOR
    
    ;; 后表面 - 灰色虚线（间隔绘制）
    PUSH 2  ; 灰色
    
    ;; 后表面上边（间隔点）
    PUSH 15 PUSH 5 PUSH 2 SET-COLOR
    PUSH 17 PUSH 5 PUSH 2 SET-COLOR
    PUSH 19 PUSH 5 PUSH 2 SET-COLOR
    PUSH 21 PUSH 5 PUSH 2 SET-COLOR
    PUSH 23 PUSH 5 PUSH 2 SET-COLOR
    PUSH 25 PUSH 5 PUSH 2 SET-COLOR
    
    ;; 后表面右边
    PUSH 25 PUSH 7 PUSH 2 SET-COLOR
    PUSH 25 PUSH 9 PUSH 2 SET-COLOR
    PUSH 25 PUSH 11 PUSH 2 SET-COLOR
    PUSH 25 PUSH 13 PUSH 2 SET-COLOR
    PUSH 25 PUSH 15 PUSH 2 SET-COLOR
    
    ;; 后表面下边
    PUSH 23 PUSH 15 PUSH 2 SET-COLOR
    PUSH 21 PUSH 15 PUSH 2 SET-COLOR
    PUSH 19 PUSH 15 PUSH 2 SET-COLOR
    PUSH 17 PUSH 15 PUSH 2 SET-COLOR
    PUSH 15 PUSH 15 PUSH 2 SET-COLOR
    
    ;; 后表面左边
    PUSH 15 PUSH 13 PUSH 2 SET-COLOR
    PUSH 15 PUSH 11 PUSH 2 SET-COLOR
    PUSH 15 PUSH 9 PUSH 2 SET-COLOR
    PUSH 15 PUSH 7 PUSH 2 SET-COLOR
    
    ;; 连接棱 - 浅灰色点线
    PUSH 3  ; 浅灰色
    
    ;; 左上连接棱
    PUSH 10 PUSH 10 PUSH 3 SET-COLOR
    PUSH 11 PUSH 9 PUSH 3 SET-COLOR
    PUSH 12 PUSH 8 PUSH 3 SET-COLOR
    PUSH 13 PUSH 7 PUSH 3 SET-COLOR
    PUSH 14 PUSH 6 PUSH 3 SET-COLOR
    PUSH 15 PUSH 5 PUSH 3 SET-COLOR
    
    ;; 右上连接棱
    PUSH 20 PUSH 10 PUSH 3 SET-COLOR
    PUSH 21 PUSH 9 PUSH 3 SET-COLOR
    PUSH 22 PUSH 8 PUSH 3 SET-COLOR
    PUSH 23 PUSH 7 PUSH 3 SET-COLOR
    PUSH 24 PUSH 6 PUSH 3 SET-COLOR
    PUSH 25 PUSH 5 PUSH 3 SET-COLOR
    
    ;; 左下连接棱
    PUSH 10 PUSH 20 PUSH 3 SET-COLOR
    PUSH 11 PUSH 19 PUSH 3 SET-COLOR
    PUSH 12 PUSH 18 PUSH 3 SET-COLOR
    PUSH 13 PUSH 17 PUSH 3 SET-COLOR
    PUSH 14 PUSH 16 PUSH 3 SET-COLOR
    PUSH 15 PUSH 15 PUSH 3 SET-COLOR
    
    ;; 右下连接棱
    PUSH 20 PUSH 20 PUSH 3 SET-COLOR
    PUSH 21 PUSH 19 PUSH 3 SET-COLOR
    PUSH 22 PUSH 18 PUSH 3 SET-COLOR
    PUSH 23 PUSH 17 PUSH 3 SET-COLOR
    PUSH 24 PUSH 16 PUSH 3 SET-COLOR
    PUSH 25 PUSH 15 PUSH 3 SET-COLOR
    
    ;; 添加一些内部线条增强立体感
    PUSH 1  ; 白色
    
    ;; 前表面对角线
    PUSH 12 PUSH 12 PUSH 1 SET-COLOR
    PUSH 13 PUSH 13 PUSH 1 SET-COLOR
    PUSH 14 PUSH 14 PUSH 1 SET-COLOR
    PUSH 15 PUSH 15 PUSH 1 SET-COLOR
    PUSH 16 PUSH 16 PUSH 1 SET-COLOR
    PUSH 17 PUSH 17 PUSH 1 SET-COLOR
    PUSH 18 PUSH 18 PUSH 1 SET-COLOR
    
    ;; 后表面对角线
    PUSH 2  ; 灰色
    PUSH 17 PUSH 7 PUSH 2 SET-COLOR
    PUSH 18 PUSH 8 PUSH 2 SET-COLOR
    PUSH 19 PUSH 9 PUSH 2 SET-COLOR
    PUSH 20 PUSH 10 PUSH 2 SET-COLOR
    PUSH 21 PUSH 11 PUSH 2 SET-COLOR
    PUSH 22 PUSH 12 PUSH 2 SET-COLOR
    PUSH 23 PUSH 13 PUSH 2 SET-COLOR
    
    HLT
))


     

(define bytecode (ASSEMBLE test-code))
(LOADER bytecode)

(displayln (dump-machine))
(display
 (RUN-MACHINE))
(displayln (dump-machine))

(render-frame-buffer)
